home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / fname.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  269 lines
  1. ;;; Code for processing Unix file names.
  2. ;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
  3. ;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
  4. ;;; notice appearing here to the effect that you may use this code any
  5. ;;; way you like, as long as you don't charge money for it, remove this
  6. ;;; notice, or hold me liable for its results.
  7.  
  8. ;;; We adhere to Posix file name rules, plus we treat files beginning with
  9. ;;; ~ as absolute paths.
  10.  
  11. ;;; Relevant bits of CScheme:
  12. ;;;    pathnm sfile strnin unxcwd unxdir unxpar unxprm unxpth unxunp wrkdir
  13.  
  14. (define (file-name-directory? fname)
  15.   (or (string=? fname "")            ; Note! "" is directory (cwd)
  16.       (char=? #\/ (string-ref fname (- (string-length fname) 1)))))
  17.  
  18. (define (file-name-non-directory? fname)
  19.   (or (string=? fname "")            ; and file-name (root).
  20.       (not (char=? #\/ (string-ref fname (- (string-length fname) 1))))))
  21.  
  22. (define (file-name-as-directory fname)
  23.   (if (string=? fname ".") ""
  24.       (let ((len (string-length fname)))
  25.     (if (and (> len 0)
  26.          (char=? #\/ (string-ref fname (- len 1))))
  27.         fname
  28.         (string-append fname "/")))))
  29.  
  30.  
  31. ;;; Return #f if str doesn't contain a slash at all.
  32. (define (last-non-slash str)
  33.   (let lp ((i (- (string-length str) 1)))
  34.     (and (>= i 0)
  35.      (if (char=? #\/ (string-ref str i))
  36.          (lp (- i 1))
  37.          i))))
  38.  
  39. (define (directory-as-file-name fname)
  40.   (let ((len (string-length fname)))
  41.     (if (zero? len) "."        ; "" -> "."
  42.  
  43.     ;; Trim trailing slashes.
  44.     (cond ((last-non-slash fname) =>
  45.            (lambda (i)
  46.          (if (= i (- len 1)) fname ; No slash.
  47.              (substring fname 0 (+ i 1))))) ; Trim slashes.
  48.  
  49.           ;;; Solid slashes -- invoke weird Posix rule.
  50.           (else (if (= len 2) "//" "/"))))))
  51.  
  52.  
  53. (define (ensure-file-name-is-directory fname)
  54.   (if (string=? fname "") ""
  55.       (file-name-as-directory fname)))
  56.  
  57.  
  58. (define (ensure-file-name-is-nondirectory fname)
  59.   (if (string=? fname "") ""
  60.       (directory-as-file-name fname)))
  61.  
  62.  
  63. (define (file-name-absolute? fname)
  64.   (or (= (string-length fname) 0)
  65.       (char=? #\/ (string-ref fname 0))
  66.       (char=? #\~ (string-ref fname 0))))
  67.  
  68.  
  69. ;;; Returns FNAME's directory component in *directory form.*
  70. (define (file-name-directory fname)
  71.   (cond ((rindex fname #\/) =>
  72.      (lambda (rslash)
  73.        (if (last-non-slash fname)
  74.            (substring fname 0 (+ 1 rslash))
  75.            ""))) ; Posix strangeness: solid slashes are root.
  76.     (else "")))
  77.  
  78.  
  79. (define (file-name-nondirectory fname)
  80.   (cond ((rindex fname #\/) =>
  81.      (lambda (rslash)
  82.        (if (last-non-slash fname)
  83.            (substring fname (+ 1 rslash) (string-length fname))
  84.            fname)))    ; Posix strangeness: solid slashes are root.
  85.     (else fname)))
  86.  
  87.     
  88. (define (split-file-name fname)
  89.   (let* ((fname (ensure-file-name-is-nondirectory fname))
  90.      (len (string-length fname)))
  91.     (let split ((start 0))
  92.       (cond ((>= start len) '())
  93.         ((index fname #\/ start) =>
  94.          (lambda (slash)
  95.            (cons (substring fname start slash)
  96.              (split (+ slash 1)))))
  97.         (else (list (substring fname start len)))))))
  98.  
  99.  
  100. (define (path-list->file-name pathlist . maybe-dir)
  101.   (let ((root (ensure-file-name-is-nondirectory (optional-arg maybe-dir ".")))
  102.     ;; Insert slashes *between* elts of PATHLIST.
  103.     (w/slashes (if (pair? pathlist)
  104.                (let insert-slashes ((pathlist pathlist))
  105.              (let ((elt (car pathlist))
  106.                    (pathlist (cdr pathlist)))
  107.                (cons elt (if (pair? pathlist)
  108.                      (cons "/" (insert-slashes pathlist))
  109.                      '()))))
  110.                '(""))))
  111.     (apply string-append
  112.        (if (and (pair? pathlist)
  113.             (string=? "" (car pathlist)))
  114.            w/slashes ; Absolute path not relocated.
  115.            (cons (file-name-as-directory root) w/slashes)))))
  116.            
  117.  
  118. (define (parse-file-name fname)
  119.   (let ((nd (file-name-nondirectory fname)))
  120.     (values (file-name-directory fname)
  121.         (file-name-sans-extension nd)
  122.         (file-name-extension nd))))
  123.  
  124.  
  125. ;;; Return the index of the . separating the extension from the rest of
  126. ;;; the file name. If no extension, returns an index pointing off the
  127. ;;; end of the string, i.e. (string-length fname). "Dot-files," such as
  128. ;;; /usr/shivers/.login are not considered extensions.
  129.  
  130. (define (file-name-extension-index fname)
  131.   (let ((dot (rindex fname #\.)))
  132.     (if (and dot
  133.          (> dot 0)
  134.          (not (char=? #\/ (string-ref fname (- dot 1)))))
  135.     dot
  136.     (string-length fname))))
  137.  
  138. (define (file-name-sans-extension fname)
  139.   (substring fname 0 (file-name-extension-index fname)))
  140.  
  141. (define (file-name-extension fname)
  142.   (substring fname (file-name-extension-index fname)
  143.                (string-length fname)))
  144.  
  145. (define (replace-extension fname ext)
  146.   (string-append (file-name-sans-extension fname) ext))
  147.  
  148.  
  149. (define (resolve-tilde-file-name fname)
  150.   (let ((len (string-length fname)))
  151.     (if (and (> len 0) (char=? #\~ (string-ref fname 0)))
  152.     (let ((tilde->homedir (lambda (end)
  153.                 (if (= end 1) home-directory ; Just ~
  154.                     (let* ((user (substring fname 1 end))
  155.                        (ui (name->user-info user)))
  156.                       (user-info:home-dir ui))))))
  157.       (cond ((index fname #\/ 1) =>
  158.          (lambda (slash)
  159.            (string-append (tilde->homedir slash) "/"
  160.                   (substring fname (+ slash 1) len))))
  161.         (else (tilde->homedir len))))
  162.     fname)))
  163.  
  164. (define (resolve-file-name fname . maybe-root)
  165.   (let* ((root (ensure-file-name-is-nondirectory (optional-arg maybe-root ".")))
  166.      (fname (ensure-file-name-is-nondirectory fname))
  167.      (len (string-length fname)))
  168.     (if (zero? len) "/"
  169.     (let ((c (string-ref fname 0)))
  170.       (cond ((char=? #\/ c) fname)     ; Absolute file name.
  171.  
  172.         ((char=? #\~ c)     ; ~ file name
  173.          (resolve-tilde-file-name fname))
  174.  
  175.         (else (string-append (file-name-as-directory root) fname)))))))
  176.  
  177.  
  178. ;;; - Remove leading and internal occurrences of dot. A trailing dot
  179. ;;;   is left alone, in case the parent is a symlink.
  180. ;;; - Remove internal and trailing double-slashes. A leading double-slash
  181. ;;;   is left alone, in accordance w/Posix. However, triple and more leading
  182. ;;;   slashes are reduced to a single slash, in accordance w/Posix.
  183. ;;; - Double-dots are left alone, in case they come after symlinks.
  184.  
  185. (define (simplify-file-name fname)
  186.   ;; First, we simplify leading multiple slashes:
  187.   ;; 1 or >2 slashes -> /, 2 slashes -> //
  188.   (receive (slashes fname)
  189.        (let ((len (string-length fname)))
  190.          (if (and (> len 0) (char=? #\/ (string-ref fname 0)))
  191.          (let ((j (let lp ((i 1)) ; j is index of first non-slash.
  192.                 (if (and (< i len)
  193.                      (char=? (string-ref fname i) #\/))
  194.                 (lp (+ i 1))
  195.                 i))))
  196.            (if (< j 3)
  197.                (values (substring fname 0 j); One or two slashes - OK.
  198.                    (substring fname j len))
  199.                (values "/" (substring fname (- j 1) len))))
  200.          (values "" fname)))
  201.  
  202.     ;; At this point, all leading slashes have been pulled off of FNAME.
  203.     ;; Any remaining repeated slashes are fair game for removal.
  204.     (let* ((path-list (split-file-name fname))
  205.        (ans (if (pair? path-list)
  206.             (reverse (let lp ((path-list path-list)
  207.                       (ans (list slashes)))
  208.                    (let ((elt (car path-list))
  209.                      (path-list (cdr path-list)))
  210.                  (if (pair? path-list)
  211.                      (lp path-list
  212.                      (if (or (string=? "." elt) ; kill .
  213.                          (string=? "" elt)) ; and //
  214.                          ans
  215.                          `("/" ,elt ,@ans)))
  216.                      (cons elt ans)))))
  217.             (list slashes))))
  218.       (apply string-append ans))))
  219.  
  220.  
  221. (define (expand-file-name fname . maybe-dir)
  222.   (simplify-file-name (apply resolve-file-name fname maybe-dir)))
  223.  
  224.  
  225. (define (home-dir . maybe-user)
  226.   (if (pair? maybe-user)
  227.       (let ((user (car maybe-user)))
  228.     (ensure-file-name-is-nondirectory
  229.         (or (%homedir user)
  230.         (error "Cannot get user's home directory"
  231.                user))))
  232.       home-directory))
  233.  
  234.  
  235. ;;; (home-file [user] fname)
  236.  
  237. (define (home-file arg1 . maybe-arg2)
  238.   (receive (dir fname)
  239.        (if (pair? maybe-arg2)
  240.            (values (home-dir arg1) (car maybe-arg2))
  241.            (values home-directory  arg1))
  242.     (string-append (file-name-as-directory dir) fname)))
  243.  
  244.  
  245. ;;; Ugh.
  246. (define (substitute-env-vars str)
  247.   (let lp ((ans '()) (s str))
  248.     (let ((len (string-length s)))
  249.       (cond
  250.         ((zero? len) (apply string-append (reverse! ans)))
  251.     ((index s #\$) =>
  252.      (lambda (i)
  253.        (let ((ans (cons (substring s 0 i) ans))
  254.          (s (substring s (+ i 1) len))
  255.          (len (- len (+ i 1))))
  256.          (if (zero? len) (lp ans "")
  257.          (let ((next-char (string-ref s 0)))
  258.            (cond ((char=? #\{ next-char)
  259.               (cond ((index s #\}) =>
  260.                  (lambda (i)
  261.                    (lp (cons (getenv (substring s 1 i)) ans)
  262.                        (substring s (+ i 1) len))))
  263.                 (else (error "Unbalanced ${ delimiter in string" s))))
  264.              (else
  265.               (let ((i (or (index s #\/) len)))
  266.                 (lp (cons (getenv (substring s 0 i)) ans)
  267.                 (substring s i len))))))))))
  268.     (else (lp (cons s ans) ""))))))
  269.